home *** CD-ROM | disk | FTP | other *** search
- ;;; This module contains code for tracing and breakpointing functions using
- ;;; the SCHEME->C interpreter. It also contains the code for an error
- ;;; handler which back traces the control stack.
-
- ;* Copyright 1989 Digital Equipment Corporation
- ;* All Rights Reserved
- ;*
- ;* Permission to use, copy, and modify this software and its documentation is
- ;* hereby granted only under the following terms and conditions. Both the
- ;* above copyright notice and this permission notice must appear in all copies
- ;* of the software, derivative works or modified versions, and any portions
- ;* thereof, and both notices must appear in supporting documentation.
- ;*
- ;* Users of this software agree to the terms and conditions set forth herein,
- ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
- ;* right and license under any changes, enhancements or extensions made to the
- ;* core functions of the software, including but not limited to those affording
- ;* compatibility with other hardware or software environments, but excluding
- ;* applications which incorporate this software. Users further agree to use
- ;* their best efforts to return to Digital any such changes, enhancements or
- ;* extensions that they make and inform Digital of noteworthy uses of this
- ;* software. Correspondence should be provided to Digital at:
- ;*
- ;* Director of Licensing
- ;* Western Research Laboratory
- ;* Digital Equipment Corporation
- ;* 100 Hamilton Avenue
- ;* Palo Alto, California 94301
- ;*
- ;* This software may be distributed (but not offered for sale or transferred
- ;* for compensation) to third parties, provided such third parties agree to
- ;* abide by the terms and conditions of this notice.
- ;*
- ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
- ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
- ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT
- ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
- ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
- ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
- ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
- ;* SOFTWARE.
-
- (module scdebug
- (top-level
- TRACED-PROCS BPT-PROCS *ARGS* *RESULT* DOTRACE TRACER
- DOUNTRACE DOBPT DOUNBPT BACKTRACE *DEBUG-ON-ERROR*))
-
- (include "repdef.sc")
-
- ;;; Nesting level for traced and breakpointed functions.
-
- (define TRACE-LEVEL 0)
-
- ;;; A-lists of traced and breakpointed functions with elements:
- ;;; (symbol original-procedure debugged-procedure).
-
- (define TRACED-PROCS '())
-
- (define BPT-PROCS '())
-
- ;;; Arguments at the time of a breakpoint are in *ARGS*, and the result is in
- ;;; *RESULT* after the function is called. A new result may be returned by
- ;;; continuing from the breakpoint with (PROCEED new-value).
-
- (define *ARGS* '())
-
- (define *RESULT* '())
-
- ;;; Function tracing
-
- (install-expander
- 'TRACE
- (lambda (x e)
- (if (cdr x)
- `(map (lambda (f) (dotrace f)) (quote ,(cdr x)))
- '(map (lambda (x) (car x)) traced-procs))))
-
- (define (DOTRACE name)
- (if (assoc name traced-procs) (dountrace name))
- (if (assoc name bpt-procs) (dounbpt name))
- (let ((proc (top-level-value name))
- (trace-proc #f))
- (if (not (procedure? proc))
- (error 'TRACE "Argument is not a PROCEDURE name"))
- (if (assoc name traced-procs)
- (error 'TRACE "~s is already traced" name))
- (set! trace-proc (tracer name proc))
- (set! traced-procs (cons (list name proc trace-proc) traced-procs))
- (set-top-level-value! name trace-proc))
- name)
-
- (define (TRACER name proc)
- (lambda x
- (format stdout-port "~a~s~%"
- (make-string (* 2 (min trace-level 15)) #\space)
- (cons name x))
- (set! trace-level (+ trace-level 1))
- (let ((result (apply proc x)))
- (set! trace-level (- trace-level 1))
- (format stdout-port "~a~a~s~%"
- (make-string (* 2 (min trace-level 15)) #\space)
- "==> " result)
- result)))
-
- (install-expander
- 'UNTRACE
- (lambda (x e)
- (if (null? (cdr x))
- (set! x (map (lambda (x) (car x)) traced-procs))
- (set! x (cdr x)))
- `(map (lambda (f) (dountrace f)) (quote ,x))))
-
- (define (DOUNTRACE name)
- (let ((name-proc-trace (assoc name traced-procs)))
- (if (not name-proc-trace)
- (error 'UNTRACE "~s is not traced" name))
- (if (eq? (top-level-value name) (caddr name-proc-trace))
- (set-top-level-value! name (cadr name-proc-trace)))
- (set! traced-procs (remove name-proc-trace traced-procs)))
- name)
-
- ;;; Function breakpoints
-
- (install-expander
- 'BPT
- (lambda (x e)
- (case (length x)
- ((1) '(map (lambda (x) (car x)) bpt-procs))
- ((2) `(apply dobpt (quote ,(cdr x))))
- ((3) (let ((func (e (caddr x) e)))
- `(apply dobpt
- (list (quote ,(cadr x)) (quote ,func)))))
- (else (error 'BPT "Illegal arguments")))))
-
- (define (DOBPT name . condition)
- (if (assoc name traced-procs) (dountrace name))
- (if (assoc name bpt-procs) (dounbpt name))
- (let ((proc (top-level-value name))
- (bpt-proc #f))
- (if (not (procedure? proc))
- (error 'BPT "Argument is not a PROCEDURE name"))
- (set! bpt-proc
- (bpter name proc (if condition (eval (car condition)))))
- (set! bpt-procs (cons (list name proc bpt-proc) bpt-procs))
- (set-top-level-value! name bpt-proc))
- name)
-
- (define BPTER-PROCNAME "")
-
- (define (BPTER name proc condition)
- (define (XEQ . args)
- (let ((ftok (enable-system-file-tasks #f)))
- (let ((result (apply read-eval-print args)))
- (enable-system-file-tasks ftok)
- result)))
- (lambda x
- (set! bpter-procname (c-tscp-ref (stacktrace) 4))
- (if (or (not condition) (apply condition x))
- (let ((prompt (format "~s- " trace-level)))
- (set! *args* x)
- (xeq
- 'header
- (format "~%~s -calls - ~s" trace-level
- (cons name x))
- 'prompt
- prompt
- 'env
- (dobacktrace bpter-procname "READ-EVAL-PRINT" 20 #f))
- (set! trace-level (+ trace-level 1))
- (set! *result* (apply proc *args*))
- (set! trace-level (- trace-level 1))
- (xeq
- 'header
- (format "~s -returns- ~s" trace-level *result*)
- 'prompt
- prompt
- 'result
- *result*
- 'env
- (dobacktrace bpter-procname "READ-EVAL-PRINT" 20 #f)))
- (apply proc x))))
-
- (install-expander
- 'UNBPT
- (lambda (x e)
- (if (null? (cdr x))
- (set! x (map (lambda (x) (car x)) bpt-procs))
- (set! x (cdr x)))
- `(map (lambda (f) (dounbpt f)) (quote ,x))))
-
- (define (DOUNBPT name)
- (let ((name-proc-bpt (assoc name bpt-procs)))
- (if (not name-proc-bpt)
- (error 'UNBPT "~s is not breakpointed" name))
- (if (eq? (top-level-value name) (caddr name-proc-bpt))
- (set-top-level-value! name (cadr name-proc-bpt)))
- (set! bpt-procs (remove name-proc-bpt bpt-procs)))
- name)
-
- ;;; The following functions are used to backtrace the control stack. The first
- ;;; performs an insertion sort to insert a new element into a list.
-
- (define (INSERTION-SORT item sorted-items before?)
- (let loop ((next sorted-items) (prev #f))
- (cond ((null? next)
- (if prev
- (begin (set-cdr! prev (list item))
- sorted-items)
- (list item)))
- ((not (before? item (car next)))
- (loop (cdr next) next))
- (prev
- (set-cdr! prev (cons item next))
- sorted-items)
- (else (cons item sorted-items)))))
-
-
- ;;; Backtracing is done by the following function. It accepts a starting
- ;;; function (or #F), a termination function (or #F), a line count, and an
- ;;; output port. It returns an environment for use with eval with the
- ;;; following definitions: all variables defined in the innermost interpreted
- ;;; environments, and variables of the form env-n whose value is the
- ;;; environment at that interpreter level.
-
- (define (DOBACKTRACE start stop lines port)
- (do ((stp (stacktrace) (c-unsigned-ref stp 0))
- (procname "")
- (envlist '())
- (envid '(env-0 env-1 env-2 env-3 env-4 env-5 env-6 env-7 env-8
- env-9 env-10 env-11 env-12 env-13 env-14 env-15 env-16
- env-17 env-18 env-19))
- (string-out (open-output-string)))
- ((or (= stp 0)
- (= lines 0)
- (null? envid)
- (and (not start) (equal? procname stop)))
- (if envlist
- (append (cdr (assq 'env-0 envlist)) envlist)
- envlist))
- (set! procname (c-tscp-ref stp 4))
- (cond (start
- (if (equal? start procname) (set! start #f)))
- ((not (string? procname))
- (when port
- (write (c-tscp-ref stp 8) string-out)
- (let ((expr (get-output-string string-out)))
- (if (> (string-length expr) 65)
- (display (string-append (substring expr 0 65)
- " ...") port)
- (display expr port)))
- (display " in " port)
- (display (car envid) port)
- (newline port))
- (set! envlist (cons (cons (car envid) procname) envlist))
- (set! envid (cdr envid))
- (set! lines (- lines 1)))
- ((member procname
- '("SCEVAL_INTERPRETED-PROC" "LOOP [inside EXEC]")))
- (else
- (when port
- (display "(" port)
- (display procname port)
- (display " ...)" port)
- (newline port))
- (set! lines (- lines 1))))))
-
- ;;; A backtrace at a breakpoint is obtained by the following function.
-
- (define (BACKTRACE . count)
- (dobacktrace bpter-procname "READ-EVAL-PRINT" (if count (car count) 20)
- stderr-port)
- #f)
-
- ;;; The default error handler is replaced by the following function when
- ;;; backtracing on error is desired. It prints the backtrace, and then
- ;;; enters a read-eval-print loop when *DEBUG-ON-ERROR* is set.
-
- (define *DEBUG-ON-ERROR* #f)
-
- (define (BACKTRACE-ERROR-HANDLER id format-string . args)
- (display (format "***** ~a " id) stderr-port)
- (display (apply format (cons format-string args)) stderr-port)
- (newline stderr-port)
- (set! *error-handler* backtrace-error-handler)
- (when *debug-on-error*
- (let ((env (dobacktrace "ERROR" "READ-EVAL-PRINT" 20 stderr-port))
- (ftok (enable-system-file-tasks #f)))
- (set! *debug-on-error* #f)
- (let loop () (when (char-ready? stdin-port)
- (if (not (eof-object?
- (read-char stdin-port)))
- (loop))))
- (read-eval-print 'prompt ">> " 'header #f 'env env)
- (enable-system-file-tasks ftok)
- (set! *debug-on-error* #t)))
- (reset))
-
- ;;; Keyboard interrupt signals are handled by the following function. If
- ;;; the interpreter is currently reading stdin, then this results in a reset.
- ;;; Otherwise, a stack trace is printed and the debugger is entered. A normal
- ;;; exit from the debugger results in the Scheme computation continuing.
-
- (define (ON-INTERRUPT sig)
- (if *reading-stdin* (reset))
- (let ((ftok (enable-system-file-tasks #f))
- (start (c-tscp-ref
- (c-unsigned-ref (c-unsigned-ref (stacktrace) 0) 0) 4)))
- (format stderr-port "~%***** INTERRUPT *****~%")
- (dobacktrace start "READ-EVAL-PRINT" 20 stderr-port)
- (read-eval-print 'header #f 'prompt ">> "
- 'env (dobacktrace start "READ-EVAL-PRINT" 20 #f))
- (enable-system-file-tasks ftok)))
-